COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 MacLisp Aids for E
C00013 00003	 A mapping function for a E entities
C00015 00004	 Sends a page of stuff, 200 liness at a time
C00016 ENDMK
C⊗;
;;; MacLisp Aids for E

(declare (special ?e:id *e:a1 *e:a2 *e:b1 *e:b2 -em:sfa-)
	 (setq defmacro-for-compiling ())
	 (muzzled t)
	 (*lexpr %match))

(defun e:goto (page line)
 (em:ecommands (append (e:make-e-control-number page)
		       '(α P)
		       (e:make-e-control-number line)
		       '(α L))))

(defun e:make-e-control-number (n)
       (cond ((zerop n)(list 'α 0))
	     (t 
	      (let ((sign (cond ((lessp n 0) '-))))
		   (setq n (abs n))
		   (do ((i n (quotient i 10.))
			(ans ()))
		       ((zerop i) (cond (sign (push sign ans)(push 'α ans)))
				  ans)
		       (push (remainder i 10.) ans)
		       (push 'α ans))))))
       
       
 (defun e:balance ()
	(let ((alist (em:readonly-vars '(line lines page pages))))
	     (let ((line (cdr (assq 'line alist)))
		   (lines (cdr (assq 'lines alist)))
		   (pages (cdr (assq 'pages alist)))
		   (page (cdr (assq 'page alist))))
		  (em:ecommands '(α - α V))
		  (e:balance2 line lines page pages)
		  (em:ecommands '(α V)) 'done)))

(defun e:balance2 (line lines page pages)
       (do ((page page (1+ page)) (cline ()))
	   ((< pages page))
	   (do ((line line (1+ line)))
	       ((< lines line)
		(or (= pages page)
		    (em:ecommands '(α p)))
		(setq line 1
		      lines
		      (cdr (assq 'lines (em:readonly-vars '(lines))))))
	       (em:ecommands '(α =))
	       (setq cline (em:tyi-message))
	       (cond ((%match
		       '(*e:a1 ?e:id ($r ? e:lbp)
			       *e:b1)
		       (reverse cline))
		      (setq *e:a1 (reverse *e:a1)
			    *e:b1 (reverse *e:b1))
		      (cond ((%match 
			      `(,@*e:b1 
				? ? *e:b2 ,?e:id ($r ? e:rbp) *e:a2)
			      cline)
			     (let ((balance (e:count-parens
					     *e:b2)))
				  (cond ((> balance 0)
					 (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					 (em:raw-ecommands
					  (append *e:b1 *e:b2 
						  (e:n-parens balance)
						  *e:a2))
					 (em:ecommands '(⊗ B α // α ⊗ ↔))
					 (setq line (1- line)))
					((< balance 0)
					 (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					 (em:raw-ecommands
					  (append 
					   *e:b1 
					   (cdr (e:flush-n-parens 
						 *e:b2
						 (minus balance))) *e:a2))
					 (em:ecommands '(⊗ B α // α ⊗ ↔))
					 (setq line (1- line)))
					(t 
					 (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					 (em:raw-ecommands 
					  (append *e:b1 *e:b2 *e:a2))
					 (em:ecommands '(⊗ B α // α ⊗ ↔))
					 (setq line (1- line)))))) 
			    (t (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
			       (em:raw-ecommands (append *e:b1 *e:a1))
			       (em:ecommands '(⊗ B α //  ⊗ ↔))
             		       (cond ((%match '(* ($r ? e:lbp) *) *e:a1)
           			      (em:ecommands '(⊗ B))
				      (let ((?e:id ())(*e:b1 ())(*e:a1()))
					   (e:balance2 line lines page pages))
              			      (e:goto page line)
           			      (em:ecommands '(α =))
				      (setq cline (em:tyi-message)) 
				      (%match `(,@*e:b1 *e:a1) cline)))
           		       (e:balance1 ?e:id (e:count-parens *e:a1)
					   (1+ line) lines page pages)
			       (e:goto page line)
			       (setq line (1- line)))))
		     (t (em:ecommands '(⊗ ↔)))))))

(defmacro e:backup ()
	  `(cond ((= line 1)
		  (cond ((= page 1)
			 (print 'Not-balanced)
			 (*throw 'out ()))
			(t (setq page (1- page))
			   (em:ecommands '(α - α P))
			   (setq lines (cdr (assq 'lines
						  (em:readonly-vars '(lines)))))
			   (setq line lines)
			   (em:ecommands (append 
					  (e:make-e-control-number lines)
					  '(α L))))))
		 (t (setq line (1- line))
		    (em:ecommands '(⊗ B)))))

(defun e:balance1 (id n line lines page pages)
 (let ((cline ()))
      (*catch 'done
	      (do ((page page (1+ page)))
		  ((< pages page)
           	   (print 'Not-balanced))
		  (do ((line line (1+ line)))
		      ((< lines line)
		       (or (= page pages)
			   (em:ecommands '(α p)))
		       (setq line 1
			     lines
			     (cdr (assq 'lines (em:readonly-vars '(lines))))))
     		      (em:ecommands '(α =))
		      (setq cline (em:tyi-message))
            	      (cond ((%match '(* ($r ? e:lbp) *) cline)
			     (let ((?e:id ())(*e:b1 ())(*e:a1 ())(*e:b2 ())(*e:a2 ()))
				  (e:balance2 line lines page pages))
			     (e:goto page line)))
           	      (cond ((%match `(*e:b1 ,id ($r ? e:rbp) *e:a1)
				     cline)
           		     (let ((balance (+ n (e:count-parens
						  *e:b1))))
           			  (cond ((> balance 0)
					 (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					 (em:raw-ecommands
						    (append *e:b1
							    (e:n-parens balance)
							    *e:a1))
					 (em:ecommands '(⊗ B α // ⊗ ↔)))
					((< balance 0)
					 (prog ()
					       again 
					       (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					       (let ((n 
						      (e:flush-n-parens *e:b1
									(minus balance))))
						    (em:raw-ecommands
						     (append 
						      (cdr n)
						      *e:a1))
						    (em:ecommands '(⊗ B α // ⊗ ↔))
						    (cond ((= (car n) 0) (return t))
							  (t
							   (e:backup)
							   (em:ecommands '(α =))
							   (setq cline (em:tyi-message))
							   (setq *e:b1 cline
								 *e:a1 ())
							   (go again))))))
					(t 
					 (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
					 (em:raw-ecommands 
					  (append *e:b1 *e:a1))
					 (em:ecommands '(⊗ B α // ⊗ ↔)))))
			     (*throw 'done t))
			    (t (em:ecommands '(α // ⊗ ↔))
			       (setq n (+ n (e:count-parens cline))))))))))

(defun e:count-parens (l)
 (do ((l l (cdr l))
      (n 0))
     ((null l) n)
     (cond ((e:lpp (car l))
	    (setq n (1+ n)))
	   ((e:rpp (car l))
	    (setq n (1- n)))
	   ((e:scp (car l))	;semi-colon
	    (return n)))))

(defun e:n-parens (n)
       (do ((n n (1- n))
	    (ans ()))
	   ((= n 0) ans)
	   (push #o51 ans)))

(defun e:flush-n-parens (l n)
	(do ((l l (cdr l))
	     (a ()))
	    ((or (null l)
		 (e:scp (car l)))
             (do ((a a (cdr a))
		  (quit ())
		  (ans ())
		  (n n))
		 ((or quit (= n 0)) `(,n . ,(append (reverse a) ans l)))
		 (cond ((e:rpp (car a))
			(setq n (1- n)))
		       ((null a)
			(setq quit t))
		       (t (push (car a) ans)))))
	    (push (car l) a)))

(defun e:scp (n)(= n #o73))
(defun e:lpp (n)(= n #o50))
(defun e:rpp (n)(= n #o51))
(defun e:lbp (n)(= n #o133))
(defun e:rbp (n)(= n #o135))

(defun e:send-current ()
 (em:ecommands '(α =))
 (read -em:sfa-))
;;; A mapping function for a E entities

;;; NIL result for fun means stay on current line, number means go up or down
;;; that amount. T means next line.

(defun e:page-map (fun)
 (em:ecommands '(α - α V))
 (do ((line (em:readonly-var 'line)) (result))
     ((< (em:readonly-var 'lines) line) (em:ecommands '(α V)) 'done)
     (em:ecommands '(α =))
     (setq result (funcall fun (em:tyi-message)))
     (cond ((numberp result)
	    (em:ecommands 
	     (append 
	      (e:make-e-control-number result) '(⊗ ↔))) 
	    (setq line (+ line result)))
	   (result (setq line (1+ line))
		   (em:ecommands '(⊗ ↔))))))

(defun e:set-current-line (cline)
       (em:raw-ecommands (append '(#o2 #o113 #o26 #o27) 
				 cline '(#o26 #o102))))

;;; Sends a page of stuff, 200 liness at a time

(defun e:send-page ()
 (let ((lines (cdr (assq 'lines (em:readonly-vars '(lines))))))
      (let ((n (quotient lines 200.)))
	   (em:ecommands '(α - α V α L))
	   (cond ((not (= 0 (remainder lines 200.)))
		  (setq n (1+ n))))
	   (do ((i n (1- i)))
	       ((= i 0) (em:ecommands '(α V)) 'done)
	       (em:ecommands '(α 2 α 0 α 0 α =))
	       (em:ecommands '(α 2 α 0 α 0 ⊗ ↔))))))